home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / sys / gc_weak.t < prev    next >
Text File  |  1988-02-05  |  8KB  |  215 lines
  1. (herald gc_weak
  2.   (env tsys (osys table))) ; TABLE is important
  3.  
  4. (define-constant gc-weak-set-list
  5.   (object (lambda ()
  6.             (process-global task/gc-weak-set-list))
  7.     ((setter self)
  8.      (lambda (k)
  9.        (set (process-global task/gc-weak-set-list) k)))))
  10.  
  11. (define-constant gc-weak-alist-list
  12.   (object (lambda ()
  13.             (process-global task/gc-weak-alist-list))
  14.     ((setter self)
  15.      (lambda (k)
  16.        (set (process-global task/gc-weak-alist-list) k)))))
  17.  
  18. (define-constant gc-weak-table-list
  19.   (object (lambda ()
  20.             (process-global task/gc-weak-table-list))
  21.     ((setter self)
  22.      (lambda (k)
  23.        (set (process-global task/gc-weak-table-list) k)))))
  24.  
  25. (define (pre-gc-fix-weak-sets)
  26.   (set (gc-weak-set-list) '()))
  27.  
  28. (define (pre-gc-fix-weak-alists)
  29.   (set (gc-weak-alist-list) '()))
  30.  
  31. (define (pre-gc-fix-weak-tables)
  32.   (set (gc-weak-table-list) '()))
  33.  
  34. ;;; Update the weak sets.  If any of the pointed to objects were copied
  35. ;;; then put the new pointer into the weak set.
  36.  
  37. (define (post-gc-fix-weak-sets)
  38.   (let ((sample (make-weak-set)))
  39.     (clear-weak-semaphore sample)
  40.     (iterate loop ((ptr (gc-weak-set-list)))
  41.       (cond ((null? ptr) nil)
  42.             (else
  43.              (let ((next (extend-header ptr)))
  44.                (set (extend-header ptr) (extend-header sample))
  45.                (modify (extend-elt ptr 0) clean-weak-set-list)
  46.                (loop next)))))))
  47.  
  48. ;;; The pairs used in weak sets and weak alists need to be clobbered in case
  49. ;;; they are not in the heap.  It may be that this only needs to be done for
  50. ;;; weaks that are not in the heap, in which case there can be two versions
  51. ;;; of this code.
  52.  
  53. (define (clean-weak-set-list lst)
  54.   (cond ((not (list? lst))
  55.          (gc-write-line ";*** weak-set list is not a list")
  56.          '())
  57.         (else
  58.          (really-clean-weak-set-list lst))))
  59.  
  60. (define (really-clean-weak-set-list lst)
  61.   (iterate loop ((lst lst) (new '()))
  62.     (cond ((null? lst)
  63.            (reverse! new))
  64.           ((atom? lst)
  65.            (gc-write-line ";*** weak-set list is not a pair")
  66.            (reverse! new))
  67.           (else
  68.            (receive (traced? new-loc)
  69.                     (get-new-copy lst)
  70.              (cond ((not traced?)
  71.                     (receive (traced? new-loc)
  72.                              (get-new-copy (car lst))
  73.                       (let ((next (cdr lst)))
  74.                         (set (car lst) 0)
  75.                         (set (cdr lst) 0)
  76.                         (loop next
  77.                               (if traced? (cons new-loc new) new)))))
  78.                    (else
  79.                     (let ((copy (copy-list new-loc)))
  80.                       (if (eq? new-loc lst)
  81.                           (iterate loop ((lst lst))
  82.                             (cond ((not (null? lst))
  83.                                    (let ((n (cdr lst)))
  84.                                      (set (car lst) 0)
  85.                                      (set (cdr lst) 0)
  86.                                      (loop n))))))
  87.                       (append! new copy)))))))))
  88.  
  89. (define (post-gc-fix-weak-alists)
  90.   (let ((sample (make-weak-alist)))
  91.     (clear-weak-semaphore sample)
  92.     (iterate loop ((ptr (gc-weak-alist-list)))
  93.       (cond ((null? ptr) nil)
  94.             (else
  95.              (let ((next (extend-header ptr)))
  96.                (set (extend-header ptr) (extend-header sample))
  97.                (modify (extend-elt ptr 0) clean-weak-alist-vector)
  98.                (loop next)))))))
  99.  
  100. ;;; The values in weak alists (as opposed to the keys) are always fixnums and
  101. ;;; thus don't need to be traced.
  102.  
  103. (define (clean-weak-alist-vector vec)
  104.   (cond ((points-to-initial-impure-memory? vec)
  105.          (really-clean-weak-alist-vector vec))
  106.         (else
  107.          (receive (traced? new-loc)
  108.                   (get-new-copy vec)
  109.            (if traced?
  110.                new-loc
  111.                (really-clean-weak-alist-vector (copy-vector vec)))))))
  112.  
  113. (define (really-clean-weak-alist-vector vec)
  114.   (let ((len (vector-length vec)))
  115.     (iterate loop ((i 0) (ni 0))
  116.       (cond ((fx>= i len)
  117.              (maybe-shrink-weak-alist-vector vec ni))
  118.             (else
  119.              (receive (traced? new-loc)
  120.                       (get-new-copy (vref vec i))
  121.                (cond ((not traced?)
  122.                       (loop (fx+ i 2) ni))
  123.                      ((fx= i ni)
  124.                       (set (vref vec i) new-loc)
  125.                       (loop (fx+ i 2) (fx+ ni 2)))
  126.                      (else
  127.                       (set (vref vec ni) new-loc)
  128.                       (set (vref vec (fx+ 1 ni)) (vref vec (fx+ 1 i)))
  129.                       (loop (fx+ i 2) (fx+ ni 2))))))))))
  130.  
  131. ;;; Weak tables
  132.  
  133. ;;; This must iterate as fixing a weak-table may cause others to be copied.
  134.  
  135. (define (post-gc-fix-weak-tables)
  136.   (iterate loop ((ptr (gc-weak-table-list)))
  137.     (set (gc-weak-table-list) '())
  138.     (cond ((null? ptr)
  139.            nil)
  140.           (else
  141.            (post-gc-fix-weak-table-list ptr)
  142.            (loop (gc-weak-table-list))))))
  143.  
  144. (define sample-weak-table (%make-weak-table))
  145.  
  146. (define (post-gc-fix-weak-table-list ptr)
  147.   (iterate loop ((ptr ptr))
  148.     (cond ((null? ptr) nil)
  149.           (else
  150.            (let ((next (extend-header ptr)))
  151.              (post-gc-clean-table ptr weak-table-update)
  152.              (loop next))))))
  153.  
  154. (define (post-gc-clean-table table update)
  155.   (set (extend-header table) (extend-header sample-weak-table))
  156.   (exchange (weak-table-vector table)
  157.             (%table-vector (weak-table-table table)))
  158.   (receive (traced? new-loc)
  159.            (get-new-copy (%table-vector (weak-table-table table)))
  160.     (cond (traced?
  161.            (set (%table-vector (weak-table-table table)) new-loc))
  162.           ((vector? (%table-vector (weak-table-table table)))
  163.            (post-gc-clean-and-shrink-table (weak-table-table table) update))
  164.           (else
  165.            (gc-write-line "; *** nonvector in weak-table")
  166.            (set (%table-vector (weak-table-table table)) empty-vec)))) 
  167.   (clear-weak-semaphore table))
  168.  
  169. (define (weak-table-update key value)
  170.   (receive (traced? new-loc)
  171.            (get-new-copy key)
  172.     (cond ((not traced?)
  173.            (return nil nil))
  174.           (else
  175.            (return new-loc (gc-copy-object value))))))
  176.  
  177. ;;;; Object hash table - a normal weak table except that it must retain pointers
  178. ;;;; to symbols.
  179. ;;;; Just call MOVE-OBJECT on OBJECT-HASH-TABLE and remove it from the
  180. ;;;; list?  ... No, it may copy others as well ...
  181. ;;;; This must be called after GC-FLIP.
  182.  
  183. (lset gc-clean-object-unhash-table? nil)
  184.  
  185. (define (object-unhash-pre-gc)
  186.   (cond ((not (weak-semaphore-set? object-unhash-table))
  187.          (set-weak-semaphore object-unhash-table)
  188.          (set gc-clean-object-unhash-table? t)
  189.          (exchange (weak-table-vector object-unhash-table)
  190.                    (%table-vector (weak-table-table object-unhash-table)))
  191.          (let ((new (gc-copy-extend object-unhash-table weak-table-slots)))
  192.            (move-object (make-pointer new 0))))
  193.         (else
  194.          (set gc-clean-object-unhash-table? nil))))
  195.  
  196. (define (object-unhash-post-gc)
  197.   (if gc-clean-object-unhash-table?
  198.       (post-gc-clean-table object-unhash-table
  199.                            object-unhash-table-update)))
  200.  
  201. ;;; This should be elsewhere
  202.  
  203. (define-constant weak-table-slots 2)
  204.  
  205. ;;; Check if the value has been copied.  The key is a fixnum and
  206. ;;; doesn't need to be copied.
  207.  
  208. (define (object-unhash-table-update key value)
  209.   (receive (traced? new-loc)
  210.            (get-new-copy value)
  211.     (cond (traced?
  212.            (return key new-loc))
  213.           (else
  214.            (return nil nil)))))
  215.